home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / exception.scm < prev    next >
Text File  |  1995-10-13  |  4KB  |  148 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ;;;; Raising and handling conditions
  6.  
  7. ; An exception is an unusual situation detected by the virtual machine.
  8. ; A condition is a run-time system structure describing unusual situations,
  9. ; including exceptions.
  10.  
  11. ; Usual exception handler vector.
  12.  
  13. (define (usual-exception-handler opcode . args)
  14.   ((vector-ref exception-handlers opcode) opcode args))
  15.  
  16. (define (define-exception-handler opcode proc)
  17.   (vector-set! exception-handlers opcode proc))
  18.  
  19. (define (signal-exception opcode args)
  20.   (really-signal-condition (make-exception opcode args)))
  21.  
  22. (define exception-handlers
  23.   (make-vector op-count signal-exception))
  24.  
  25.  
  26. ; TRAP is the same as SIGNAL-CONDITION.
  27.  
  28. (define-exception-handler (enum op trap)
  29.   (lambda (opcode args)
  30.     (if (pair? (car args)) ;minimal attempt at condition well-formedness
  31.     (really-signal-condition (car args))
  32.     (signal-exception opcode args))))
  33.  
  34. ; This is for generic arithmetic, mostly
  35.  
  36. (define make-opcode-generic!
  37.   (let ((except (lambda (opcode)
  38.           (lambda (next-method . args)
  39.             (signal-exception opcode args))))
  40.     (handler (lambda (perform)
  41.            (lambda (opcode args)
  42.              ((perform) args)))))
  43.     (lambda (opcode mtable)
  44.       (set-final-method! mtable (except opcode))
  45.       (define-exception-handler opcode
  46.     (handler (method-table-get-perform mtable))))))
  47.  
  48. ; Raising and handling conditions.
  49. ; (fluid $condition-handlers) is a list of handler procedures.
  50. ; Each handler takes two arguments: the condition to be handled, and
  51. ; a thunk that can be called if the handler decides to decline handling
  52. ; the condition.  The continuation to a call to a handler is that
  53. ; of the call to signal-condition.
  54.  
  55. (define (really-signal-condition condition)
  56.   (let loop ((hs (fluid $condition-handlers)))
  57.     ((car hs) condition (lambda () (loop (cdr hs))))))
  58.  
  59. (define (with-handler h thunk)
  60.   (let-fluid $condition-handlers
  61.       (cons h (fluid $condition-handlers))
  62.     thunk))
  63.  
  64. (define $condition-handlers
  65.   (make-fluid #f))
  66.  
  67.  
  68. (define (initialize-exceptions! thunk)
  69.   (call-with-current-continuation
  70.     (lambda (k)
  71.       (set-fluid! $condition-handlers
  72.           (list (last-resort-condition-handler k)))
  73.       (set-exception-handler! usual-exception-handler)
  74.       (thunk))))
  75.  
  76. (define (last-resort-condition-handler halt)
  77.   (let ((interrupt/keyboard (enum interrupt keyboard))
  78.     (losing? #f))
  79.     (lambda (condition punt)
  80.       (cond ((error? condition)
  81.          (primitive-catch
  82.            (lambda (c)
  83.          (if (not losing?)
  84.              (begin (set! losing? #t)
  85.                 (report-utter-lossage condition c)))
  86.          (halt 123))))
  87.         ((and (interrupt? condition)
  88.           (= (cadr condition) interrupt/keyboard))
  89.          (halt 2))
  90.         (else (unspecific))))))    ;proceed
  91.  
  92. ; This will print a list of template id's, which you can look up in
  93. ; initial.debug to get some idea of what was going on.
  94.  
  95. (define (report-utter-lossage condition c)
  96.   (let ((out (error-output-port)))
  97.     (if out
  98.     (begin
  99.       (if (exception? condition)
  100.           (begin
  101.         (write-string (number->string (exception-opcode condition))
  102.                   out)
  103.         (write-string " / " out)))
  104.       (for-each (lambda (id+pc)
  105.               (if (number? (car id+pc))
  106.               (write-string (number->string
  107.                      (car id+pc))
  108.                     out))
  109.               (write-string " <- " out))
  110.             (continuation-preview c))
  111.       (newline out)))))
  112.  
  113. (define (continuation-preview c)
  114.   (if (continuation? c)
  115.       (cons (cons (template-info (continuation-template c))
  116.           (continuation-pc c))
  117.         (continuation-preview (continuation-parent c)))
  118.       '()))
  119.  
  120.  
  121. ; ERROR is a compiler primitive, but if it weren't, it could be
  122. ; defined as follows:
  123.  
  124. ;(define (error message . irritants)
  125. ;  (signal-condition (make-condition 'error (cons message irritants))))
  126.  
  127.  
  128. (define (ignore-errors thunk)
  129.   (call-with-current-continuation
  130.     (lambda (k)
  131.       (with-handler (lambda (c next)
  132.               (if (error? c)
  133.               (k c)
  134.               (next)))
  135.     thunk))))
  136.  
  137.  
  138.  
  139. ; Define disclosers that are most important for error messages.
  140.  
  141. (define-method &disclose ((obj :closure))
  142.   (list 'procedure (template-ref (closure-template obj) 1)))
  143.  
  144. (define-method &disclose ((obj :location))
  145.   (list 'location (location-id obj)))
  146.  
  147. ; (put 'with-handler 'scheme-indent-hook 1)
  148.